home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Tech Arsenal 1
/
Tech Arsenal (Arsenal Computer).ISO
/
tek-02
/
gatekp.zip
/
GATEKPR2.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1993-01-04
|
5KB
|
239 lines
{$O+,F+}
unit gatekpr2;
(* Password Unit *)
{ Public Domain Coding By Remi Aubuchon, 1990 }
{ CompuServe # 71660,1016 }
interface
CONST
VCHAR = '*'; {Character that will echo on screen}
DEFAULT_PASSWORD = 'NOPASSWORD'; {Will bypass Procedure}
TYPE
PassString = string[10];
Function Encode(Str:PassString):PassString; {Gives back an encoded version of the password}
Function Decode(Str:PassString):PassString; {Gives back an decoded version of the password}
Procedure Gate_Keeper(PassKey:PassString); {Checks Password}
implementation
USES
Crt,WIN;
type
TitleStrPtr = ^TitleStr;
WinRecPtr = ^WinRec;
WinRec = record
Next: WinRecPtr;
State: WinState;
Title: TitleStrPtr;
TitleAttr, FrameAttr: Byte;
Buffer: Pointer;
end;
var
TopWindow: WinRecPtr;
WindowCount: Integer;
Done: Boolean;
Ch: Char;
Pass_Enter : PassString;
Gate_Count : ShortInt;
AOK : BOOLEAN;
Function GetKey:CHAR;
var key: char;
begin
key := ReadKey;
If key = #0 then key := ReadKey; {If its a special function key}
GetKey := key;
end;
Procedure WriteAT(X,Y,F,B:BYTE;SayWhat:STRING);
begin
TextColor(F);
TextBackground(B);
GotoXY(X,Y);
Writeln(SayWhat);
end;
Procedure WriteCenter(y,f,b:BYTE;CntrString:STRING);
VAR
X:BYTE;
begin
X :=20-(LENGTH(CntrString) DIV 2);
WriteAT(x,y,f,b,CntrString);
end;
procedure OpenWindow(X1, Y1, X2, Y2: Byte; T: TitleStr;
TAttr, FAttr: Byte);
var
W: WinRecPtr;
begin
New(W);
with W^ do
begin
Next := TopWindow;
SaveWin(State);
GetMem(Title, Length(T) + 1);
Title^ := T;
TitleAttr := TAttr;
FrameAttr := FAttr;
Window(X1, Y1, X2, Y2);
GetMem(Buffer, WinSize);
ReadWin(Buffer^);
FrameWin(T, DoubleFrame, TAttr, FAttr);
end;
TopWindow := W;
Inc(WindowCount);
end;
procedure CloseWindow;
var
W: WinRecPtr;
begin
if TopWindow <> nil then
begin
W := TopWindow;
with W^ do
begin
UnFrameWin;
WriteWin(Buffer^);
FreeMem(Buffer, WinSize);
FreeMem(Title, Length(Title^) + 1);
RestoreWin(State);
TopWindow := Next;
end;
Dispose(W);
Dec(WindowCount);
end;
end;
Function Encode(Str:Passstring):Passstring;
var
I : integer;
begin
For I := 1 to 10 do
begin
CASE I OF
1,3,5,7,9: Str[I] := chr(ord(Str[I]) + 5);
2,4,6,8,10 : Str[I] := chr(ord(str[I])-5);
end;
end;
Encode := Str;
end;
Function Decode(Str:Passstring):Passstring;
var
I : integer;
begin
For I := 1 to 10 do
begin
CASE I OF
1,3,5,7,9: Str[I] := chr(ord(Str[I]) - 5);
2,4,6,8,10 : Str[I] := chr(ord(str[I])+5);
end;
end;
Decode := Str;
end;
PROCEDURE Process( VAR RawPass: PassString);
CONST
FillString = ' ';
VAR
i: INTEGER;
begin
IF LENGTH (RawPass) < 10 THEN
RawPass := RawPass +COPY(FillString,1,10-LENGTH(RawPass));
FOR i := 1 to 10 DO
If ord(RawPass[I]) in [97..122] then
RawPass[I] := chr(ord(RawPass[I]) - 32);
end;
PROCEDURE Pass_Check(VAR Pass_Enter: PassString);
VAR
PCcount: BYTE;
Ch: CHAR;
BEGIN
Pass_Enter := '';
PCcount := 0;
ClrScr;
WriteAT(4, 3, Red, LightGray, 'Enter Password:');
REPEAT
GotoXY(20+PCcount,3);
Ch := GetKey;
IF ch <> #13 THEN
BEGIN
Pass_Enter := Pass_Enter + Ch;
WriteAT(20 + PCcount, 3, Red, LightGray, Vchar);
INC(PCcount);
END
ELSE
BEGIN
PCcount := 10;
END;
UNTIL PCcount = 10;
Process(Pass_Enter);
END;
PROCEDURE Gate_Keeper(Passkey: PassString);
BEGIN
IF Passkey <> DEFAULT_PASSWORD THEN
BEGIN
Process(Passkey);
AOK := False;
Gate_Count := 0;
OpenWindow(20, 10, 60, 15, 'Password Required!',red, red);
REPEAT
Pass_Check(Pass_Enter);
IF Pass_Enter <> PassKey THEN
BEGIN
ClrScr;
WriteCenter(3, Red, black, 'Invalid Entry - Try Again!');
Sound(700);
Delay(200);
NoSound;
Delay(1000);
Pass_Enter := '';
INC(Gate_Count);
END
ELSE
BEGIN
Gate_Count := 2;
AOK := True;
END;
UNTIL Gate_Count = 2;
IF NOT AOK THEN
BEGIN
ClrScr;
WriteCenter(3, Red, black, 'Entry - Denied!');
Sound(100);
Delay(300);
NoSound;
Delay(2000);
CloseWindow;
ClrScr;
Halt(1); {That's it!}
END
ELSE
BEGIN
ClrScr;
WriteCenter(3, white, black, 'Welcome!');
Sound(1000);
Delay(100);
NoSound;
Delay(2000);
CloseWindow;
TextColor(lightgray);
TextBackground(black);
END;
END;
END;
END.